home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / gcontext.l < prev    next >
Text File  |  1988-09-12  |  40KB  |  951 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; GContext
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. ;;;    GContext values are usually cached locally in the GContext object.
  22. ;;;    This is required because the X.11 server doesn't have any requests
  23. ;;;    for getting GContext values back.
  24. ;;;
  25. ;;;    GContext changes are cached until force-GContext-changes is called.
  26. ;;;    All the requests that use GContext (including the GContext accessors,
  27. ;;;    but not the SETF's) call force-GContext-changes.
  28. ;;;    In addition, the macro WITH-GCONTEXT may be used to provide a 
  29. ;;;    local view if a GContext.
  30. ;;;
  31. ;;;    Each GContext keeps a copy of the values the server has seen, and
  32. ;;;    a copy altered by SETF, called the LOCAL-STATE (bad name...).
  33. ;;;    The SETF accessors increment a timestamp in the GContext.
  34. ;;;    When the timestamp in a GContext isn't equal to the timestamp in
  35. ;;;    the local-state, changes have been made, and force-GContext-changes
  36. ;;;    loops through the GContext and local-state, sending differences to
  37. ;;;    the server, and updating GContext.
  38. ;;;
  39. ;;;    WITH-GCONTEXT works by BINDING the local-state slot in a GContext to
  40. ;;;    a private copy.  This is easy (and fast) for lisp machines, but other
  41. ;;;    lisps will have problems.  Fortunately, most other lisps don't care,
  42. ;;;    because they don't run in a multi-processing shared-address space
  43. ;;;    environment.
  44.  
  45. (in-package 'xlib :use '(lisp))
  46.  
  47. (export '(force-gcontext-changes
  48.       with-gcontext
  49.       create-gcontext
  50.       copy-gcontext-components
  51.       copy-gcontext
  52.       free-gcontext
  53.       
  54.       gcontext-function
  55.       gcontext-plane-mask
  56.       gcontext-foreground
  57.       gcontext-background
  58.       gcontext-line-width
  59.       gcontext-line-style
  60.       gcontext-cap-style
  61.       gcontext-join-style
  62.       gcontext-fill-style
  63.       gcontext-fill-rule
  64.       gcontext-tile
  65.       gcontext-stipple
  66.       gcontext-ts-x
  67.       gcontext-ts-y
  68.       gcontext-font
  69.       gcontext-subwindow-mode
  70.       gcontext-exposures
  71.       gcontext-clip-x
  72.       gcontext-clip-y
  73.       gcontext-clip-mask
  74.       gcontext-dashes
  75.       gcontext-arc-mode
  76.       gcontext-dash-offset
  77.           gcontext-clip-ordering
  78.  
  79.       define-gcontext-accessor
  80.       ))
  81.  
  82. ;; GContext state accessors
  83. ;;    The state vector contains all card32s to speed server updating
  84.  
  85. (eval-when (eval compile load)
  86.  
  87. (defconstant *gcontext-fast-change-length* #.(length *gcontext-components*))
  88.  
  89. )
  90.  
  91. (eval-when (eval compile)
  92.  
  93. (defmacro def-gc-internals (name &rest extras)
  94.   (let ((macros nil)
  95.     (indexes nil)
  96.     (masks nil)
  97.     (index 0))
  98.     (dolist (name *gcontext-components*)
  99.       (push `(defmacro ,(xintern 'gcontext-internal- name) (state)
  100.            `(svref ,state ,,index))
  101.         macros)
  102.       (setf (getf indexes name) index)
  103.       (push (ash 1 index) masks)
  104.       (incf index))
  105.     (dolist (extra extras)
  106.       (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state)
  107.            `(svref ,state ,,index))
  108.         macros)
  109.       (setf (getf indexes (or (second extra) (first extra))) index)
  110.       (push (logior (ash 1 index)
  111.             (if (second extra)
  112.             (ash 1 (position (second extra) *gcontext-components*))
  113.             0))
  114.         masks)
  115.       (incf index))
  116.     `(within-definition (def-gc-internals ,name)
  117.        ,@(nreverse macros)
  118.        (eval-when (eval compile load)
  119.      (defconstant *gcontext-data-length* ,index)
  120.      (defconstant *gcontext-indexes* ',indexes)
  121.      (defconstant *gcontext-masks* ',(coerce (nreverse masks) 'simple-vector))))))
  122.  
  123. )
  124.  
  125. (def-gc-internals ignore
  126.           (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp))
  127.  
  128. (deftype gcmask () '(unsigned-byte #.*gcontext-fast-change-length*))
  129.  
  130. (deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*))
  131.  
  132. (defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named
  133.   (name nil :type symbol :read-only t)
  134.   (default nil :type t :read-only t)
  135.   (set-function #'identity :type (function (gcontext t) t) :read-only t)
  136.   (copy-function #'identity :type (function (gcontext gcontext t) t) :read-only t))
  137.  
  138. (defvar *gcontext-extensions* nil) ;; list of gcontext-extension
  139.  
  140. ;; Gcontext state Resource
  141. (defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states
  142.  
  143. (defun allocate-gcontext-state ()
  144.   ;; Allocate a gcontext-state
  145.   ;; Loop until a local state is found that's large enough to hold
  146.   ;; any extensions that may exist.
  147.   (do ((length (+ *gcontext-data-length* (length *gcontext-extensions*)))
  148.        (state (atomic-pop *gcontext-local-state-cache*)
  149.           (atomic-pop *gcontext-local-state-cache*)))
  150.       ((or (null state) (>= (length state) length))
  151.        (if state
  152.        (progn
  153.          (fill (the gcontext-state state) nil)
  154.          state)
  155.      (make-array length :initial-element nil)))))
  156.  
  157. (defun deallocate-gcontext-state (state)
  158.   (atomic-push state *gcontext-local-state-cache*))
  159.  
  160. ;; Temp-Gcontext Resource
  161. (defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts
  162.  
  163. (defun allocate-temp-gcontext ()
  164.   (or (atomic-pop *temp-gcontext-cache*)
  165.       (make-gcontext :local-state '#() :server-state '#())))
  166.  
  167. (defun deallocate-temp-gcontext (gc)
  168.   (atomic-push gc *temp-gcontext-cache*))
  169.  
  170. ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
  171. ;; as (type <type> <name>), there is an accessor:
  172.  
  173. ;(defun gcontext-<name> (gcontext)
  174. ;  ;; The value will be nil if the last value stored is unknown (e.g., the cache was
  175. ;  ;; off, or the component was copied from a gcontext with unknown state).
  176. ;  (declare (type gcontext gcontext)
  177. ;       (values <type>)))
  178.  
  179. ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
  180. ;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
  181.  
  182. ;(defsetf gcontext-<name> (gcontext) (value)
  183. ;  )
  184.  
  185. ;; Generate all the accessors and defsetf's for GContext
  186.  
  187. (eval-when (eval compile)  ;; I'd rather use macrolet, but Symbolics doesn't like it...
  188.  
  189. (defmacro xgcmask->gcmask (mask)
  190.   `(the gcmask (logand ,mask #.(1- (ash 1 *gcontext-fast-change-length*)))))
  191.  
  192. (defmacro access-gcontext ((gcontext local-state) &body body)
  193.   `(let ((,local-state (gcontext-local-state ,gcontext)))
  194.      (declare (type gcontext-state ,local-state))
  195.      ,@body))
  196.  
  197. (defmacro modify-gcontext ((gcontext local-state) &body body)
  198.   ;; The timestamp must be altered after the modification
  199.   `(let ((,local-state (gcontext-local-state ,gcontext)))
  200.      (declare (type gcontext-state ,local-state))
  201.      (prog1
  202.      (progn ,@body)
  203.        (setf (gcontext-internal-timestamp ,local-state) 0))))
  204.  
  205. (defmacro def-gc-accessor (name type)
  206.   (let* ((gcontext-name (xintern 'gcontext- name))
  207.      (internal-accessor (xintern 'gcontext-internal- name))
  208.      (internal-setfer (xintern 'set- gcontext-name)))
  209.     `(within-definition (,name def-gc-accessor)
  210.  
  211.        (defun ,gcontext-name (gcontext)
  212.      (declare (type gcontext gcontext))
  213.      (declare-values (or null ,type))
  214.      (compiler-let ((*buffer* '(gcontext-display gcontext)))
  215.        (let ((value (,internal-accessor (gcontext-local-state gcontext))))
  216.          (declare (type (or null card32) value))
  217.          (when value ;; Don't do anything when value isn't known
  218.            (decode-type ,type value)))))
  219.        
  220.        (defun ,internal-setfer (gcontext value)
  221.      (declare (type gcontext gcontext)
  222.           (type ,type value))
  223.      (compiler-let ((*buffer* '(gcontext-display gcontext)))
  224.        (modify-gcontext (gcontext local-state)
  225.          (setf (,internal-accessor local-state) (encode-type ,type value))
  226.          ,@(when (eq type 'pixmap)
  227.          ;; write-through pixmaps, because the protocol allows
  228.          ;; the server to copy the pixmap contents at the time
  229.          ;; of the store, rather than continuing to share with
  230.          ;; the pixmap.
  231.          `((let ((server-state (gcontext-server-state gcontext)))
  232.              (setf (,internal-accessor server-state) nil))))
  233.          value)))
  234.        
  235.        (defsetf ,gcontext-name ,internal-setfer))))
  236.  
  237. (defmacro incf-internal-timestamp (state)
  238.   (let ((ts (gensym)))
  239.     `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state))))
  240.        (declare (type fixnum ,ts))
  241.        ;; the probability seems low enough
  242.        (setq ,ts (if (= ,ts most-positive-fixnum)
  243.              1
  244.              (the fixnum (1+ ,ts))))
  245.        (setf (gcontext-internal-timestamp ,state) ,ts))))
  246.  
  247. ) ;; End eval-when
  248.  
  249. (def-gc-accessor function boole-constant)
  250. (def-gc-accessor plane-mask card32)
  251. (def-gc-accessor foreground card32)
  252. (def-gc-accessor background card32)
  253. (def-gc-accessor line-width card16)
  254. (def-gc-accessor line-style (member :solid :dash :double-dash))
  255. (def-gc-accessor cap-style (member :not-last :butt :round :projecting))
  256. (def-gc-accessor join-style (member :miter :round :bevel))
  257. (def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled))
  258. (def-gc-accessor fill-rule (member :even-odd :winding))
  259. (def-gc-accessor tile pixmap)
  260. (def-gc-accessor stipple pixmap)
  261. (def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin
  262. (def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin
  263. ;; (def-GC-accessor font font) ;; See below
  264. (def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors))
  265. (def-gc-accessor exposures (member :off :on))
  266. (def-gc-accessor clip-x int16)
  267. (def-gc-accessor clip-y int16)
  268. ;; (def-GC-accessor clip-mask) ;; see below
  269. (def-gc-accessor dash-offset card16)
  270. ;; (def-GC-accessor dashes)  ;; see below
  271. (def-gc-accessor arc-mode (member :chord :pie-slice))
  272.  
  273.  
  274. (defun gcontext-clip-mask (gcontext)
  275.   (declare (type gcontext gcontext))
  276.   (declare-values (or null (member :none) pixmap rect-seq)
  277.           (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))
  278.   (access-gcontext (gcontext local-state)
  279.     (compiler-let ((*buffer* '(gcontext-display gcontext)))
  280.       (let ((clip (gcontext-internal-clip local-state)))
  281.     (values (or (third clip)
  282.             (decode-type (or (member :none) pixmap) (second clip)))
  283.         (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
  284.                  (first clip)))))))
  285.  
  286. (defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
  287.   ;; A bit strange, but retains setf form.
  288.   ;; a nil clip-mask is transformed to an empty vector
  289.   `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask))
  290.  
  291. (defun set-gcontext-clip-mask (gcontext ordering clip-mask)
  292.   ;; a nil clip-mask is transformed to an empty vector
  293.   (declare (type gcontext gcontext)
  294.        (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering)
  295.        (type (or (member :none) pixmap rect-seq) clip-mask))
  296.   (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))
  297.   (modify-gcontext (gcontext local-state)
  298.     ;; need single setf for atomicity
  299.     (setf (gcontext-internal-clip local-state)
  300.       (cons (encode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
  301.                  ordering)
  302.         (typecase clip-mask
  303.           (pixmap
  304.            (let ((server-state (gcontext-server-state gcontext)))
  305.              ;; write-through clip-mask pixmap, because the
  306.              ;; protocol allows the server to copy the pixmap
  307.              ;; contents at the time of the store, rather than
  308.              ;; continuing to share with the pixmap.
  309.              (setf (gcontext-internal-clip-mask server-state) nil))
  310.            (list (pixmap-id clip-mask)))
  311.           ((member :none) '(0))
  312.           (sequence (list nil clip-mask))
  313.           (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq))))))
  314.     clip-mask))
  315.  
  316. (defun gcontext-dashes (gcontext)
  317.   (declare (type gcontext gcontext))
  318.   (declare-values (or null card8 sequence))
  319.   (access-gcontext (gcontext local-state)
  320.     (let ((dash (gcontext-internal-dash local-state)))
  321.       (or (first dash) (second dash)))))
  322.  
  323. (defsetf gcontext-dashes set-gcontext-dashes)
  324.  
  325. (defun set-gcontext-dashes (gcontext dashes)
  326.   (declare (type gcontext gcontext)
  327.        (type (or card8 sequence) dashes))
  328.   (modify-gcontext (gcontext local-state)
  329.     ;; need single setf for atomicity
  330.     (setf (gcontext-internal-dash local-state)
  331.       (if (type? dashes 'sequence)
  332.           (if (zerop (length dashes))
  333.           (x-type-error dashes '(or card8 sequence) "non-empty sequence")
  334.         (list nil (or dashes (vector))))
  335.           (list (encode-type card8 dashes))))
  336.     dashes))
  337.  
  338. (defun gcontext-font (gcontext &optional metrics-p)
  339.   ;; If the stored font is known, it is returned.  If it is not known and
  340.   ;; metrics-p is false, then nil is returned.  If it is not known and
  341.   ;; metrics-p is true, then a pseudo font is returned.  Full metric and
  342.   ;; property information can be obtained, but the font does not have a name or
  343.   ;; a resource-id, and attempts to use it where a resource-id is required will
  344.   ;; result in an invalid-font error.
  345.   (declare (type gcontext gcontext)
  346.        (type boolean metrics-p))
  347.   (declare-values (or null font))
  348.   (access-gcontext (gcontext local-state)
  349.     (let ((font (gcontext-internal-font-obj local-state)))
  350.       (or font
  351.       (when metrics-p
  352.         ;; XXX this isn't correct
  353.         (make-font :display (gcontext-display gcontext)
  354.                :id (gcontext-id gcontext)
  355.                :name nil))))))
  356.  
  357. (defsetf gcontext-font set-gcontext-font)
  358.  
  359. (defun set-gcontext-font (gcontext font)
  360.   (declare (type gcontext gcontext)
  361.        (type fontable font))
  362.     (let ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font))))
  363.       ;; XXX need to check font has id (and name?)
  364.       (modify-gcontext (gcontext local-state)
  365.     (setf (gcontext-internal-font-obj local-state) font-object)
  366.     font)))
  367.  
  368. (defun force-gcontext-changes (gcontext)
  369.   ;; Force any delayed changes.
  370.   (declare (type gcontext gcontext))
  371.   (let ((display (gcontext-display gcontext))
  372.     (server-state (gcontext-server-state gcontext))
  373.     (local-state (gcontext-local-state gcontext))
  374.     local-clip local-dash)
  375.     (declare-array gcontext-state server-state local-state)
  376.       ;; Update server when timestamps don't match
  377.     (unless (= (the fixnum (gcontext-internal-timestamp local-state))
  378.            (the fixnum (gcontext-internal-timestamp server-state)))
  379.       (with-display (display)
  380.     ;; first unpack a few things
  381.     (setq local-clip (gcontext-internal-clip local-state))
  382.     (if (setf (gcontext-internal-clip-mask local-state) (second local-clip))
  383.         (setf (gcontext-internal-clip server-state) local-clip)
  384.         (setf (gcontext-internal-clip-mask server-state) nil))
  385.     (setq local-dash (gcontext-internal-dash local-state))
  386.     (if (setf (gcontext-internal-dashes local-state) (first local-dash))
  387.         (setf (gcontext-internal-dash server-state) local-dash)
  388.         (setf (gcontext-internal-dashes server-state) nil))
  389.     (let ((local-font (gcontext-internal-font-obj local-state)))
  390.       (if local-font
  391.           (progn
  392.         (setf (gcontext-internal-font local-state) (font-id local-font))
  393.         (setf (gcontext-internal-font-obj server-state) local-font))
  394.           (setf (gcontext-internal-font server-state) nil)))
  395.       
  396.     ;; Because there is no locking on the local state we have to
  397.     ;; assume that state will change and set timestamps up front,
  398.     ;; otherwise by the time we figured out there were no changes
  399.     ;; and tried to store the server stamp as the local stamp, the
  400.     ;; local stamp might have since been modified.
  401.     (setf (gcontext-internal-timestamp local-state)
  402.           (incf-internal-timestamp server-state))
  403.  
  404.     (block no-changes
  405.       (let ((last-request (buffer-last-request display)))
  406.         (with-buffer-request (display *x-changegc*)
  407.           (gcontext gcontext)
  408.           (progn
  409.         (do ((i 0 (index+ i 1))
  410.              (bit 1 (the xgcmask (ash bit 1)))
  411.              (nbyte 12)
  412.              (mask 0)
  413.              (local 0))
  414.             ((index>= i *gcontext-fast-change-length*)
  415.              (when (zerop mask)
  416.                ;; If nothing changed, restore last-request and quit
  417.                (setf (buffer-last-request display)
  418.                  (if (zerop (buffer-last-request display))
  419.                  nil
  420.                    last-request))
  421.                (return-from no-changes nil))
  422.              (card29-put 8 mask)
  423.              (card16-put 2 (index-ash nbyte -2))
  424.              (index-incf (buffer-boffset display) nbyte))
  425.           (declare (type array-index i nbyte)
  426.                (type xgcmask bit)
  427.                (type gcmask mask)
  428.                (type (or null card32) local))
  429.           (unless (eql (the (or null card32) (svref server-state i))
  430.                    (setq local (the (or null card32) (svref local-state i))))
  431.             (setf (svref server-state i) local)
  432.             (card32-put nbyte local)
  433.             (setq mask (the gcmask (logior mask bit)))
  434.             (index-incf nbyte 4)))))))
  435.  
  436.     ;; Update GContext extensions
  437.     (do ((extension *gcontext-extensions* (cdr extension))
  438.          (i *gcontext-data-length* (index+ i 1))
  439.          (local))
  440.         ((endp extension))
  441.       (unless (eql (svref server-state i)
  442.                (setq local (svref local-state i)))
  443.         (funcall (gcontext-extension-set-function (car extension))
  444.              gcontext local)
  445.         (setf (svref server-state i) local)))
  446.  
  447.     ;; Update clipping rectangles
  448.     (unless (eq (third local-clip)
  449.             (third (gcontext-internal-clip server-state)))
  450.       (setf (gcontext-internal-clip server-state) local-clip)
  451.       (with-buffer-request (display *x-setcliprectangles*)
  452.         (data (first local-clip))
  453.         (gcontext gcontext)
  454.         ;; XXX treat nil correctly
  455.         (card16 (or (gcontext-internal-clip-x local-state) 0)
  456.             (or (gcontext-internal-clip-y local-state) 0))
  457.         ;; XXX this has both int16 and card16 values
  458.         ((sequence :format int16) (third local-clip))))
  459.  
  460.     ;; Update dashes
  461.     (unless (eq (second local-dash)
  462.             (second (gcontext-internal-dash server-state)))
  463.       (setf (gcontext-internal-dash server-state) local-dash)
  464.       (with-buffer-request (display *x-setdashes*)
  465.         (gcontext gcontext)
  466.         ;; XXX treat nil correctly
  467.         (card16 (or (gcontext-internal-dash-offset local-state) 0)
  468.             (length (second local-dash)))
  469.         ((sequence :format card8) (second local-dash))))))))
  470.  
  471. ;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE
  472. ;;;         SET IN THE GCONTEXT ON ENTRY.  BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN
  473. ;;;         UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN
  474. ;;;         COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS
  475. ;;;          BACK.
  476.  
  477. (defmacro with-gcontext ((gcontext &rest options &key clip-ordering &allow-other-keys)
  478.              &body body)
  479.   ;; "Binds" the gcontext components specified by options within the
  480.   ;; dynamic scope of the body (i.e., indefinite scope and dynamic
  481.   ;; extent), on a per-process basis in a multi-process environment.
  482.   ;; The body is not surrounded by a with-display.  If cache-p is nil or
  483.   ;; the some component states are unknown, this will implement
  484.   ;; save/restore by creating a temporary gcontext and doing
  485.   ;; copy-gcontext-components to and from it.
  486.  
  487.   (declare-arglist (gcontext &rest options &key
  488.                  function plane-mask foreground background
  489.                  line-width line-style cap-style join-style fill-style fill-rule
  490.                  arc-mode tile stipple ts-x ts-y font subwindow-mode
  491.                  exposures clip-x clip-y clip-mask clip-ordering
  492.                  dash-offset dashes &allow-other-keys)
  493.            &body body)
  494.   (remf options :clip-ordering)
  495.  
  496.   (let ((gc (gensym))
  497.     (saved-state (gensym))
  498.     (temp-gc (gensym))
  499.     (temp-mask (gensym))
  500.     (temp-var (gensym))
  501.     (need-temp-var nil)
  502.     (setfs nil)
  503.     (indexes nil)                ; List of gcontext field indices
  504.     (extension-indexes nil)            ; List of gcontext extension field indices
  505.     (ts-index (getf *gcontext-indexes* :timestamp)))
  506.  
  507.     (do* ((option options (cddr option))
  508.       (name (car option) (car option))
  509.       (value (cadr option) (cadr option)))
  510.      ((endp option) (setq setfs (nreverse setfs)))
  511.       (let ((index (getf *gcontext-indexes* name)))
  512.     (if index
  513.         (push index indexes)
  514.       (let ((extension (find name *gcontext-extensions* :key #'gcontext-extension-name)))
  515.         (if extension
  516.         (progn
  517.           (push (xintern "Internal-" 'gcontext- name "-State-Index")
  518.             extension-indexes))
  519.           (x-type-error name 'gcontext-key)))))
  520.       (let ((accessor `(,(xintern 'gcontext- name) ,gc ,@(when (eq name :clip-mask)
  521.                                `(,clip-ordering)))))
  522.     (cond ((not (constantp value))
  523.            (setq need-temp-var t)
  524.            (push `(when (setq ,temp-var ,value) (setf ,accessor ,temp-var))
  525.              setfs))
  526.           (value
  527.            (push `(setf ,accessor ,value) setfs)))))
  528.     (when need-temp-var
  529.       (setq setfs `((let (,temp-var) ,@setfs))))
  530.     (if setfs
  531.     `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc)
  532.          (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes)
  533.        (declare (type gcontext ,gc)
  534.             (type gcontext-state ,saved-state)
  535.             (type xgcmask ,temp-mask)
  536.             (type (or null resource-id) ,temp-gc))
  537.        (with-gcontext-bindings (,gc ,saved-state ,(append indexes extension-indexes)
  538.                     ,ts-index ,temp-mask ,temp-gc)
  539.          ,@setfs
  540.          ,@body))
  541.       `(progn ,@body))))
  542.  
  543. (defun copy-gcontext-local-state (gcontext indexes &rest extension-indices)
  544.   ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK
  545.   (declare (type gcontext gcontext)
  546.        (type list indexes))
  547.   (let ((local-state (gcontext-local-state gcontext))
  548.     (saved-state (allocate-gcontext-state))
  549.     (cache-p (gcontext-cache-p gcontext)))
  550.     (declare-array gcontext-state local-state saved-state)
  551.     (setf (gcontext-internal-timestamp saved-state) 1)
  552.     (let ((temp-gc nil)
  553.       (temp-mask 0)
  554.       (extension-mask 0))
  555.       (declare (type xgcmask temp-mask)
  556.            (type integer extension-mask))
  557.       (dolist (i indexes)
  558.     (when (or (not (setf (svref saved-state i) (svref local-state i)))
  559.           (not cache-p))
  560.       (setq temp-mask
  561.         (the xgcmask (logior temp-mask
  562.                      (the xgcmask (svref *gcontext-masks* i)))))))
  563.       (dolist (i extension-indices)
  564.     (when (or (not (setf (svref saved-state i) (svref local-state i)))
  565.           (not cache-p))
  566.       (setq extension-mask
  567.         (the xgcmask (logior extension-mask (ash 1 i))))))
  568.       (when (or (plusp temp-mask)
  569.         (plusp extension-mask))
  570.     ;; Copy to temporary GC when field unknown or cache-p false
  571.     (let ((display (gcontext-display gcontext)))
  572.       (declare (type display display))
  573.       (with-display (display)
  574.         (setq temp-gc (allocate-temp-gcontext))
  575.         (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext)
  576.           (gcontext-display temp-gc) display
  577.           (gcontext-drawable temp-gc) (gcontext-drawable gcontext)
  578.           (gcontext-server-state temp-gc) saved-state
  579.           (gcontext-local-state temp-gc) saved-state)
  580.         ;; Create a new (temporary) gcontext
  581.         (with-buffer-request (display *x-creategc*)
  582.           (gcontext temp-gc)
  583.           (drawable (gcontext-drawable gcontext))
  584.           (card29 0))
  585.         ;; Copy changed components to the temporary gcontext
  586.         (when (plusp temp-mask)
  587.           (with-buffer-request (display *x-copygc*)
  588.         (gcontext gcontext)
  589.         (gcontext temp-gc)
  590.         (card29 (xgcmask->gcmask temp-mask))))
  591.         ;; Copy extension fields to the new gcontext
  592.         (when (plusp extension-mask)
  593.           ;; Copy extension fields from temp back to gcontext
  594.           (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1))
  595.            (i 0 (index+ i 1)))
  596.           ((zerop bit))
  597.         (let ((copy-function (gcontext-extension-copy-function
  598.                        (elt *gcontext-extensions* i))))
  599.           (funcall copy-function gcontext temp-gc
  600.                (svref local-state (+ i *gcontext-data-length*))))))
  601.         )))
  602.       (values gcontext saved-state (logior temp-mask extension-mask) temp-gc))))
  603.  
  604. (defun restore-gcontext-temp-state (gcontext temp-mask temp-gc)
  605.   (declare (type gcontext gcontext temp-gc)
  606.        (type xgcmask temp-mask))
  607.   (let ((display (gcontext-display gcontext)))
  608.     (declare (type display display))
  609.     (with-display (display)
  610.       (with-buffer-request (display *x-copygc*)
  611.     (gcontext temp-gc)
  612.     (gcontext gcontext)
  613.     (card29 (xgcmask->gcmask temp-mask)))
  614.       ;; Copy extension fields from temp back to gcontext
  615.       (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1))
  616.        (extensions *gcontext-extensions* (cdr extensions))
  617.        (i *gcontext-data-length* (index+ i 1))
  618.        (local-state (gcontext-local-state temp-gc)))
  619.       ((zerop bit))
  620.     (let ((copy-function (gcontext-extension-copy-function (car extensions))))
  621.       (funcall copy-function temp-gc gcontext (svref local-state i))))
  622.       ;; free gcontext
  623.       (with-buffer-request (display *x-freegc*)
  624.     (gcontext temp-gc))
  625.       (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext)
  626.       (deallocate-temp-gcontext temp-gc)
  627.       ;; Copy saved state back to server state
  628.       (do ((server-state (gcontext-server-state gcontext))
  629.        (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1)))
  630.        (i 0 (index+ i 1)))
  631.       ((zerop bit)
  632.        (incf-internal-timestamp server-state))
  633.     (declare (type gcontext-state server-state)
  634.          (type gcmask bit)
  635.          (type array-index i))
  636.     (when (oddp bit)
  637.       (setf (svref server-state i) nil))))))
  638.  
  639. (defun create-gcontext (&rest options &key (drawable (required-arg drawable))
  640.             function plane-mask foreground background
  641.             line-width line-style cap-style join-style fill-style fill-rule
  642.             arc-mode tile stipple ts-x ts-y font subwindow-mode
  643.             exposures clip-x clip-y clip-mask clip-ordering
  644.             dash-offset dashes
  645.             (cache-p t)
  646.             &allow-other-keys)
  647.   ;; Only non-nil components are passed on in the request, but for effective caching
  648.   ;; assumptions have to be made about what the actual protocol defaults are.  For
  649.   ;; all gcontext components, a value of nil causes the default gcontext value to be
  650.   ;; used.  For clip-mask, this implies that an empty rect-seq cannot be represented
  651.   ;; as a list.  Note:  use of stringable as font will cause an implicit open-font.
  652.   ;; Note:  papers over protocol SetClipRectangles and SetDashes special cases.  If
  653.   ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
  654.   ;; component will have no effect unless the new value differs from the cached
  655.   ;; value.  Component changes (setfs and with-gcontext) are always deferred
  656.   ;; regardless of the cache mode, and sent over the protocol only when required by a
  657.   ;; local operation or by an explicit call to force-gcontext-changes.
  658.   (declare (type drawable drawable) ; Required to be non-null
  659.        (type (or null boole-constant) function)
  660.        (type (or null pixel) plane-mask foreground background)
  661.        (type (or null card16) line-width dash-offset)
  662.        (type (or null int16) ts-x ts-y clip-x clip-y)
  663.        (type (or null (member :solid :dash :double-dash)) line-style)
  664.        (type (or null (member :not-last :butt :round :projecting)) cap-style)
  665.        (type (or null (member :miter :round :bevel)) join-style)
  666.        (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
  667.        (type (or null (member :even-odd :winding)) fill-rule)
  668.        (type (or null (member :chord :pie-slice)) arc-mode)
  669.        (type (or null pixmap) tile stipple)
  670.        (type (or null fontable) font)
  671.        (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
  672.        (type (or null (member :on :off)) exposures)
  673.        (type (or null (member :none) pixmap rect-seq) clip-mask)
  674.        (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
  675.        (type (or null card8 sequence) dashes)
  676.        (type boolean cache-p))
  677.   (declare-values gcontext)
  678.   (let* ((display (drawable-display drawable))
  679.      (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p))
  680.      (local-state (gcontext-local-state gcontext))
  681.      (server-state (gcontext-server-state gcontext))
  682.      (gcontextid (allocate-resource-id display gcontext 'gcontext)))
  683.     (declare (type display display)
  684.          (type gcontext gcontext)
  685.          (type resource-id gcontextid))
  686.     (declare-array gcontext-state local-state server-state)
  687.     (setf (gcontext-id gcontext) gcontextid)
  688.  
  689.     (unless function (setf (gcontext-function gcontext) boole-1))
  690.     ;; using the depth of the drawable would be better, but ...
  691.     (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff))
  692.     (unless foreground (setf (gcontext-foreground gcontext) 0))
  693.     (unless background (setf (gcontext-background gcontext) 1))
  694.     (unless line-width (setf (gcontext-line-width gcontext) 0))
  695.     (unless line-style (setf (gcontext-line-style gcontext) :solid))
  696.     (unless cap-style (setf (gcontext-cap-style gcontext) :butt))
  697.     (unless join-style (setf (gcontext-join-style gcontext) :miter))
  698.     (unless fill-style (setf (gcontext-fill-style gcontext) :solid))
  699.     (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd))
  700.     (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice))
  701.     (unless ts-x (setf (gcontext-ts-x gcontext) 0))
  702.     (unless ts-y (setf (gcontext-ts-y gcontext) 0))
  703.     (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext)
  704.                  :clip-by-children))
  705.     (unless exposures (setf (gcontext-exposures gcontext) :on))
  706.     (unless clip-mask (setf (gcontext-clip-mask gcontext) :none))
  707.     (unless clip-x (setf (gcontext-clip-x gcontext) 0))
  708.     (unless clip-y (setf (gcontext-clip-y gcontext) 0))
  709.     (unless dashes (setf (gcontext-dashes gcontext) 4))
  710.     (unless dash-offset (setf (gcontext-dash-offset gcontext) 0))
  711.     ;; a bit kludgy, but ...
  712.     (replace server-state local-state)
  713.  
  714.     (when function (setf (gcontext-function gcontext) function))
  715.     (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask))
  716.     (when foreground (setf (gcontext-foreground gcontext) foreground))
  717.     (when background (setf (gcontext-background gcontext) background))
  718.     (when line-width (setf (gcontext-line-width gcontext) line-width))
  719.     (when line-style (setf (gcontext-line-style gcontext) line-style))
  720.     (when cap-style (setf (gcontext-cap-style gcontext) cap-style))
  721.     (when join-style (setf (gcontext-join-style gcontext) join-style))
  722.     (when fill-style (setf (gcontext-fill-style gcontext) fill-style))
  723.     (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule))
  724.     (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode))
  725.     (when tile (setf (gcontext-tile gcontext) tile))
  726.     (when stipple (setf (gcontext-stipple gcontext) stipple))
  727.     (when ts-x (setf (gcontext-ts-x gcontext) ts-x))
  728.     (when ts-y (setf (gcontext-ts-y gcontext) ts-y))
  729.     (when font (setf (gcontext-font gcontext) font))
  730.     (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode))
  731.     (when exposures (setf (gcontext-exposures gcontext) exposures))
  732.     (when clip-x (setf (gcontext-clip-x gcontext) clip-x))
  733.     (when clip-y (setf (gcontext-clip-y gcontext) clip-y))
  734.     (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask))
  735.     (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset))
  736.     (when dashes (setf (gcontext-dashes gcontext) dashes))
  737.     
  738.     (setf (gcontext-internal-timestamp server-state) 1)
  739.     (setf (gcontext-internal-timestamp local-state) 1)
  740.     
  741.     (let ((local-clip (gcontext-internal-clip local-state)))
  742.       (if (setf (gcontext-internal-clip-mask local-state) (second local-clip))
  743.       (setf (gcontext-internal-clip server-state) local-clip)
  744.       (setf (gcontext-internal-timestamp local-state) 0)))
  745.     (let ((local-dash (gcontext-internal-dash local-state)))
  746.       (if (setf (gcontext-internal-dashes local-state) (first local-dash))
  747.       (setf (gcontext-internal-dash server-state) local-dash)
  748.       (setf (gcontext-internal-timestamp local-state) 0)))
  749.     (let ((local-font (gcontext-internal-font-obj local-state)))
  750.       (when local-font
  751.     (setf (gcontext-internal-font local-state) (font-id local-font))
  752.     (setf (gcontext-internal-font-obj server-state) local-font)))
  753.  
  754.     (with-buffer-request (display *x-creategc*)
  755.       (resource-id gcontextid)
  756.       (drawable drawable)
  757.       (progn (do* ((i 0 (index+ i 1))
  758.            (bit 1 (the xgcmask (ash bit 1)))
  759.            (nbyte 16)
  760.            (mask 0)
  761.            (local (svref local-state i) (svref local-state i)))
  762.          ((index>= i *gcontext-fast-change-length*)
  763.           (card29-put 12 mask)
  764.           (card16-put 2 (index-ash nbyte -2))
  765.           (index-incf (buffer-boffset display) nbyte))
  766.            (declare (type array-index i nbyte)
  767.             (type xgcmask bit)
  768.             (type gcmask mask)
  769.             (type (or null card32) local))
  770.            (unless (eql local (the (or null card32) (svref server-state i)))
  771.          (setf (svref server-state i) local)
  772.          (card32-put nbyte local)
  773.          (setq mask (the gcmask (logior mask bit)))
  774.          (index-incf nbyte 4)))))
  775.  
  776.     ;; Initialize extensions
  777.     (do ((extensions *gcontext-extensions* (cdr extensions))
  778.      (i *gcontext-data-length* (index+ i 1)))
  779.     ((endp extensions))
  780.       (setf (svref server-state i)
  781.         (setf (svref local-state i)
  782.           (gcontext-extension-default (car extensions)))))
  783.  
  784.     ;; Set extension values
  785.     (do* ((option-list options (cddr option-list))
  786.       (option (car option-list) (car option-list))
  787.       (extension))
  788.      ((endp option-list))
  789.       (cond ((getf *gcontext-indexes* option))    ; Gcontext field
  790.         ((member option '(:drawable :clip-ordering :cache-p)))    ; Optional parameter
  791.         ((setq extension (find option *gcontext-extensions*
  792.                    :key #'gcontext-extension-name))
  793.          (funcall (gcontext-extension-set-function extension)
  794.               gcontext (second option-list)))
  795.         (t (x-type-error option 'gcontext-key))))
  796.     gcontext))
  797.  
  798. (defun copy-gcontext-components (src dst &rest keys)
  799.   (declare (type gcontext src dst)
  800.        (type list keys)) ;; list of GContext-key
  801.   ;; you might ask why this isn't just a bunch of
  802.   ;;   (setf (gcontext-<mumble> dst) (gcontext-<mumble> src))
  803.   ;; the answer is that you can do that yourself if you want, what we are
  804.   ;; providing here is access to the protocol request, which will generally
  805.   ;; be more efficient (particularly for things like clip and dash lists).
  806.   (when keys
  807.     (let ((display (gcontext-display src))
  808.       (mask 0))
  809.       (declare (type xgcmask mask))
  810.       (with-display (display)
  811.     (force-gcontext-changes src)
  812.     (force-gcontext-changes dst)
  813.     
  814.     ;; collect entire mask and handle extensions
  815.     (dolist (key keys)
  816.       (let ((i (getf *gcontext-indexes* key)))
  817.         (declare (type (or null array-index) i))
  818.         (if i
  819.         (setq mask (the xgcmask (logior mask
  820.                         (the xgcmask (svref *gcontext-masks* i)))))
  821.           (multiple-value-bind (extension index)
  822.           (find key *gcontext-extensions* :key #'gcontext-extension-name)
  823.         (if extension
  824.             (funcall (gcontext-extension-copy-function extension)
  825.                  src dst (svref (gcontext-local-state src)
  826.                         (+ index *gcontext-data-length*)))
  827.           (x-type-error key 'gcontext-key))))))
  828.     
  829.     (when (plusp mask)
  830.       (do ((src-server-state (gcontext-server-state src))
  831.            (dst-server-state (gcontext-server-state dst))
  832.            (dst-local-state (gcontext-local-state dst))
  833.            (bit mask (the xgcmask (ash bit -1)))
  834.            (i 0 (index+ i 1)))
  835.           ((zerop bit)
  836.            (incf-internal-timestamp dst-server-state)
  837.            (setf (gcontext-internal-timestamp dst-local-state) 0))
  838.         (declare (type gcontext-state src-server-state dst-server-state dst-local-state)
  839.              (type xgcmask bit)
  840.              (type array-index i))
  841.         (when (oddp bit)
  842.           (setf (svref dst-local-state i)
  843.             (setf (svref dst-server-state i) (svref src-server-state i)))))
  844.       (with-buffer-request (display *x-copygc*)
  845.         (gcontext src dst)
  846.         (card29 (xgcmask->gcmask mask))))))))
  847.  
  848. (defun copy-gcontext (src dst)
  849.   (declare (type gcontext src dst))
  850.   ;; Copies all components.
  851.   (apply #'copy-gcontext-components src dst *gcontext-components*)
  852.   (do ((extensions *gcontext-extensions* (cdr extensions))
  853.        (i *gcontext-data-length* (index+ i 1)))
  854.       ((endp extensions))
  855.     (funcall (gcontext-extension-copy-function (car extensions))
  856.          src dst (svref (gcontext-local-state src) i))))
  857.        
  858. (defun free-gcontext (gcontext)
  859.   (declare (type gcontext gcontext))
  860.   (let ((display (gcontext-display gcontext)))
  861.     (with-buffer-request (display *x-freegc*)
  862.       (gcontext gcontext))
  863.     (deallocate-resource-id display (gcontext-id gcontext) 'gcontext)
  864.     (deallocate-gcontext-state (gcontext-server-state gcontext))
  865.     (deallocate-gcontext-state (gcontext-local-state gcontext))
  866.     nil))
  867.  
  868. (defmacro define-gcontext-accessor (name &key default set-function copy-function)
  869.   ;; This will define a new gcontext accessor called NAME.
  870.   ;; Defines the gcontext-NAME accessor function and its defsetf.
  871.   ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when
  872.   ;; gcontext-cache-p is true.  The NAME keyword will be allowed in
  873.   ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS.
  874.   ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE)
  875.   ;; from create-gcontext, and force-gcontext-changes.
  876.   ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value)
  877.   ;; from copy-gcontext and copy-gcontext-components.
  878.   ;; The copy-function defaults to:
  879.   ;; (lambda (ignore dst-gc value)
  880.   ;;    (if value
  881.   ;;        (,set-function dst-gc value)
  882.   ;;      (error "Can't copy unknown GContext component ~a" ',name)))
  883.   (declare (type symbol name)
  884.        (type t default)
  885.        (type (function (gcontext t) t) set-function) ;; required
  886.        (type (or null (function (gcontext gcontext t) t))
  887.          copy-function))
  888.   (let* ((gc-name (intern (concatenate 'string
  889.                        (string 'gcontext-)
  890.                        (string name)))) ;; in current package
  891.      (key-name (kintern name))
  892.      (setfer (xintern "Set-" gc-name))
  893.      (internal-set-function (xintern "Internal-Set-" gc-name))
  894.      (internal-copy-function (xintern "Internal-Copy-" gc-name))
  895.      (internal-state-index (xintern "Internal-" gc-name "-State-Index")))
  896.     (unless copy-function
  897.       (setq copy-function
  898.         `(lambda (src-gc dst-gc value)
  899.            (declare (ignore src-gc))
  900.            (if value
  901.            (,set-function dst-gc value)
  902.          (error "Can't copy unknown GContext component ~a" ',name)))))
  903.     `(progn
  904.        (eval-when (compile load eval)
  905.      (defparameter ,internal-state-index
  906.                (add-gcontext-extension ',key-name ,default ',internal-set-function
  907.                            ',internal-copy-function))
  908.      ) ;; end eval-when
  909.        (defun ,gc-name (gcontext)
  910.      (svref (gcontext-local-state gcontext) ,internal-state-index))
  911.        (defun ,setfer (gcontext new-value)
  912.      (let ((local-state (gcontext-local-state gcontext)))
  913.        (setf (gcontext-internal-timestamp local-state) 0)
  914.        (setf (svref local-state ,internal-state-index) new-value)))
  915.        (defsetf ,gc-name ,setfer)
  916.        (defun ,internal-set-function (gcontext new-value)
  917.      (,set-function gcontext new-value)
  918.      (setf (svref (gcontext-server-state gcontext) ,internal-state-index)
  919.            (setf (svref (gcontext-local-state gcontext) ,internal-state-index)
  920.              new-value)))
  921.        (defun ,internal-copy-function (src-gc dst-gc new-value)
  922.      (,copy-function src-gc dst-gc new-value)
  923.      (setf (svref (gcontext-local-state dst-gc) ,internal-state-index)
  924.            (setf (svref (gcontext-server-state dst-gc) ,internal-state-index)
  925.              new-value)))
  926.        ',name)))
  927.  
  928. ;; GContext extension fields are treated in much the same way as normal GContext
  929. ;; components.  The current value is stored in a slot of the gcontext-local-state,
  930. ;; and the value known to the server is in a slot of the gcontext-server-state.
  931. ;; The slot-number is defined by its position in the *gcontext-extensions* list.
  932. ;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is 
  933. ;; the extension component name) reflects this position.  The position within
  934. ;; *gcontext-extensions* and the value of the special value are determined at
  935. ;; LOAD time to facilitate merging of seperately compiled extension files.
  936.  
  937. (defun add-gcontext-extension (name default-value set-function copy-function)
  938.   (declare (type symbol name)
  939.        (type t default-value)
  940.        (type (function (gcontext t) t) set-function)
  941.        (type (function (gcontext gcontext t) t) copy-function))
  942.   (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
  943.             (prog1 (length *gcontext-extensions*)
  944.                (push nil *gcontext-extensions*)))))
  945.     (setf (nth number *gcontext-extensions*)
  946.       (make-gcontext-extension :name name
  947.                    :default default-value
  948.                    :set-function set-function
  949.                    :copy-function copy-function))
  950.     (+ number *gcontext-data-length*)))
  951.